perm filename STRUCT[1,LMM] blob
sn#013282 filedate 1972-11-18 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE "18-NOV-72 3:55:47")
T)
(LISPXTERPRI T))
(LISPXPRINT (QUOTE STRUCTUREVARS)
T)
(RPAQQ STRUCTUREVARS
((FNS FREEVALENCESIZE NODES COLLECTFV CATALOG STRUCWITH2NODES
CATALOG3 DAISY SINGLERING BIVCHAIN CONNECT COPYSTRUC
DISCONNECT FINDCTE FIRSTOFNODES LASTOFNODES
LISTBYVALENCE PUTFVN PUTFVS PUTNEWNODE PUTNEWNODEINCT
NODEVALENCE VALENCETYPE INSERTMARKERS ATTACHFVS
ATTACHBIVALENTS ATTACHBIVS&LOOPS PUTLOOPS PUTBIVN
PUTBIVS PUTBIVE)
(VARS LASTNODE)
(!RECORD STRUCTURE)
(RECORD RADICAL)
(RECORD MAKECENTER)
(RECORD MARKER-REC)
(!RECORD CTENTRY)
(RECORD EDGE)
(PROP RECDEFAULT GROUP)
(PROP RECDEFAULT MARKERS)
(!RECORD STRUCFORM)
(ADVISE ATTACHBIVALENTS ATTACHBIVS&LOOPS ATTACHFVS
STRUCTURESWITHATOMS)))
(DEFINEQ
(FREEVALENCESIZE
[LAMBDA (S)
(IF (STRUCTURE? S)
THEN
(FOR NEW X IN (CTABLE S)
FOR NEW Y IN (NBRS X)
WHEN
(EQ Y (QUOTE FV))
IPLUS 1)
ELSEIF
(STRUCFORM? S)
THEN
(IF (EQ (CAR (FORM S))
(QUOTE ATTACHFVS))
THEN
(FOR NEW FVL IN (CADR (FORM S))
FOR NEW X IN FVL AS NEW I := (1 999999)
IPLUS
(ITIMES I X))
ELSE
(FREEVALENCESIZE (CADDR (FORM S])
(NODES
[LAMBDA (STRUC)
(MAPCAR (CTABLE STRUC)
(FUNCTION (LAMBDA (X)
(NODENUM X])
(COLLECTFV
[LAMBDA (S)
(FOR NEW CT IN (CTABLE S)
FOR NEW X IN (NBRS CT)
WHEN
(EQ X (QUOTE FV))
XLIST
(NODENUM CT])
(CATALOG
[LAMBDA (L)
(IF (AND (EQP (*PLUS (SETQ L (TRIMZEROS L)))
2)
(EQP (CAR (LAST L))
2))
THEN
[LIST (STRUCWITH2NODES (IPLUS 2 (LENGTH L]
ELSE
(CATALOG3 L])
(STRUCWITH2NODES
[LAMBDA (N)
(STRUCTURE UGRAPH = (CONS (QUOTE MBONDS)
N)
CTABLE = (LIST (CTENTRY NODENUM = 1 NBRS =
(FOR NEW I := (1 N)
XLIST 2))
(CTENTRY NODENUM = 2 NBRS =
(FOR NEW I := (1 N)
XLIST 1)))
LASTNODE# = 2])
(CATALOG3
[LAMBDA (TVL)
(PROG (C)
[COND
([NOT (ZEROP (*PLUS (CDR TVL]
NIL)
(T (SETQ C (NTH CATALOG-LIST (QUOTIENT (CAR TVL)
2]
(RETURN (IF (AND C (CAR C))
THEN
(CAR C)
ELSE
(LIST (STRUCFORM FORM = (LIST (QUOTE CATALOG)
TVL])
(DAISY
[LAMBDA (PART)
(PROG (S C)
(SETQ LASTNODE 1)
(SETQ S (STRUCTURE UGRAPH= (CONS ' DAISY PART)
CTABLE = (LIST (CTENTRY NODENUM = LASTNODE)
)
LASTNODE# = LASTNODE))
(SETQ C LASTNODE)
(RETURN (LIST (FOR NEW PAIR IN PART FOR NEW I :=
(1 (CDR PAIR))
PROGN
(SETQ S (PUTBIVN S C (CAR PAIR])
(SINGLERING
[LAMBDA (N)
(PROG (S)
(SETQ LASTNODE 0)
(SETQ S (BIVCHAIN N))
(CONNECT (FINDCTE (FIRSTOFNODES S)
S)
(FINDCTE (LASTOFNODES S)
S))
(RETURN (STRUCTURE FROM S UGRAPH = (CONS (QUOTE SINGLERING)
N])
(BIVCHAIN
[LAMBDA (N)
(FOR NEW I := (1 N)
AS NEW X IS X PROGN (SETQ X (PUTNEWNODE X])
(CONNECT
[LAMBDA (X Y)
(PROG NIL
(REPLACE (NBRS X)
(CONS (NODENUM Y)
(NBRS X)))
(COND
((NOT (EQ X Y))
(REPLACE (NBRS Y)
(CONS (NODENUM X)
(NBRS Y])
(COPYSTRUC
[LAMBDA (S)
(PROGN (SETQ LASTNODE (LASTNODE# S))
(COPY S])
(DISCONNECT
[LAMBDA (X Y)
(PROG NIL
(REPLACE (NBRS X)
(DELETE (NODENUM Y)
(NBRS X)))
(REPLACE (NBRS Y)
(DELETE (NODENUM X)
(NBRS Y])
(FINDCTE
[LAMBDA (N LST)
(COND
((NUMBERP N)
(COND
((STRUCTURE? LST)
(SETQ LST (CTABLE LST)))
(T NIL))
(FOR NEW L IN LST WHEN (EQUAL (NODENUM L)
N)
DO
(RETURN L)))
((NUMBERP LST)
(FINDCTE LST N))
(T (ERROR (QUOTE (BAD ARGUMENTS TO FINDCTE])
(FIRSTOFNODES
[LAMBDA (X)
(CAR (NODES X])
(LASTOFNODES
[LAMBDA (X)
(CAR (LAST (NODES X])
(LISTBYVALENCE
[LAMBDA (S)
(PROG (M V)
(SETQ M (LENGTH (NODES S)))
(RETURN (FOR NEW I := (2 999)
WHILE
(IGREATERP M 0)
LIST
(SETQ V (VALENCETYPE S I))
(SETQ M (IDIFFERENCE M (LENGTH V)))
V])
(PUTFVN
[LAMBDA (S N J)
(PROG NIL
(SETQ N (FINDCTE N (CTABLE S)))
[REPLACE (NBRS N)
(NCONC (NBRS N)
(FOR NEW I := (1 J)
XLIST
(QUOTE FV]
(RETURN S])
(PUTFVS
[LAMBDA (S FVP)
(FOR NEW NI IN FVP FOR NEW NIJ IN NI AS NEW J := (1 10)
FOR NEW NODE IN NIJ PROGN (SETQ S (PUTFVN S NODE J])
(PUTNEWNODE
[LAMBDA (STRUC)
(IF STRUC THEN (PROGN (SETQ LASTNODE (ADD1 (LASTNODE# STRUC)))
(STRUCTURE FROM STRUC CTABLE =
(PUTNEWNODEINCT (CTENTRY NODENUM =
LASTNODE)
(CTABLE OF STRUC))
LASTNODE# = LASTNODE))
ELSE
(PROGN (SETQ LASTNODE (ADD1 LASTNODE))
(STRUCTURE CTABLE = (LIST (CTENTRY NODENUM = LASTNODE))
LASTNODE# = LASTNODE])
(PUTNEWNODEINCT
[LAMBDA (X Y)
(PROG (Z)
(SETQ Z (CAR Y))
(REPLACE (NBRS OF Z)
(CONS (NODENUM X)
(NBRS Z)))
(REPLACE (NBRS OF X)
(CONS (NODENUM Z)
(NBRS X)))
(RETURN (CONS X Y])
(NODEVALENCE
[LAMBDA (NODE)
(IF (NULL NODE)
THEN
(ERROR ' (NULL NODE GIVEN TO NODEVALENCE))
ELSEIF
(CTENTRY? NODE)
THEN
(LENGTH (NBRS NODE))
ELSE
(NODEVALENCE (FINDCTE (CAR NODE)
(CDR NODE])
(VALENCETYPE
[LAMBDA (S I)
(FOR NEW NODE IN (CTABLE S)
WHEN
(EQP I (NODEVALENCE NODE))
XLIST
(NODENUM NODE])
(INSERTMARKERS
[LAMBDA (STRUC CLL L)
(PROG NIL
(FOR NEW CL IN CLL AS NEW NLL IN L FOR NEW PAIR IN CL AS NEW
NL IN NLL FOR NEW N IN NL DO
(REPLACE (ATOMTYPE (MARKERS (FINDCTE N STRUC)))
(CAR PAIR)))
(RETURN STRUC])
(ATTACHFVS
[LAMBDA (FVP STRUC)
(FOR NEW L IN (LLABELNODES STRUC FVP)
XLIST
(PUTFVS (COPYSTRUC (LSTRUC L))
(LABELED L])
(ATTACHBIVALENTS
[LAMBDA (PART STRUC)
(FOR NEW L IN (LABELEDGES STRUC (CDRLIST PART))
XLIST
(PUTBIVS (COPYSTRUC (LSTRUC L))
(*CARLIST PART)
(LABELED L])
(ATTACHBIVS&LOOPS
[LAMBDA (EL LL STRUC)
(IF (NOT EL)
THEN
(FOR NEW L2 IN (LLABELNODES STRUC (LCDRLIST LL))
XLIST
(PUTLOOPS (COPYSTRUC (LSTRUC L2))
(LCARLIST LL)
(LABELED L2)))
ELSE
(FOR NEW L1 IN (LABELEDGES STRUC (CDRLIST EL))
FOR NEW L2 IN (LLABELNODES (LSTRUC L1)
(LCDRLIST LL))
XLIST
(PUTLOOPS (PUTBIVS (COPYSTRUC (LSTRUC L2))
(*CARLIST EL)
(LABELED L1))
(LCARLIST LL)
(LABELED L2])
(PUTLOOPS
[LAMBDA (STRUC LPS LNODES)
(PROG2 [FOR NEW LOBJ IN LNODES AS NEW LLABS IN LPS FOR NEW OBJ IN
LOBJ AS NEW LAB IN LLABS FOR NEW LPPR IN LAB FOR NEW I
:= (1 (CDR LPPR))
FOR NEW NODE IN OBJ DO (SETQ STRUC (PUTBIVN
STRUC NODE (CAR LPPR]
STRUC])
(PUTBIVN
[LAMBDA (STRUC NODE NBIVS)
(IF (ZEROP NBIVS)
THEN STRUC ELSE (PROG (B)
(SETQ B (BIVCHAIN NBIVS))
[CONNECT (CAR (CTABLE B))
(SETQ NODE (FINDCTE
NODE
(CTABLE STRUC]
(CONNECT (CAR (LAST (CTABLE B)))
NODE)
(NCONC (CTABLE STRUC)
(CTABLE B))
(REPLACE (LASTNODE# STRUC)
(LASTNODE# B))
(RETURN STRUC])
(PUTBIVS
[LAMBDA (S L LST)
(PROG2 (FOR NEW X IN LST AS NEW N IN L FOR NEW E IN X DO
(PUTBIVE S E N))
S])
(PUTBIVE
[LAMBDA (S E N)
(IF (ZEROP N)
THEN S ELSE (PROG (B N1 N2)
(SETQ B (BIVCHAIN N))
[CONNECT (CAR (CTABLE B))
(SETQ N1 (FINDCTE (CAR E)
(CTABLE S]
[CONNECT (CAR (LAST (CTABLE B)))
(SETQ N2 (FINDCTE (CDR E)
(CTABLE S]
(DISCONNECT N1 N2)
(NCONC (CTABLE S)
(CTABLE B))
(REPLACE (LASTNODE# S)
(LASTNODE# B))
(RETURN S])
)
(RPAQQ LASTNODE 6)
(DEFLIST(QUOTE(
(STRUCTURE (CTABLE UGRAPH LASTNODE# . GROUP))
))(QUOTE !RECORD))
(!RECORD (QUOTE STRUCTURE))
(DEFLIST(QUOTE(
(RADICAL (CENTER . ATTACHEDRADS))
))(QUOTE RECORD))
(RECORD (QUOTE RADICAL))
(DEFLIST(QUOTE(
(MAKECENTER (AFFLINK RADSTRUC . CUFFLINKS))
))(QUOTE RECORD))
(RECORD (QUOTE MAKECENTER))
(DEFLIST(QUOTE(
(MARKER-REC (ATOMTYPE . OTHERMARKERS))
))(QUOTE RECORD))
(RECORD (QUOTE MARKER-REC))
(DEFLIST(QUOTE(
(CTENTRY (NODENUM MARKERS . NBRS))
))(QUOTE !RECORD))
(!RECORD (QUOTE CTENTRY))
(DEFLIST(QUOTE(
(EDGE (NODE1 . NODE2))
))(QUOTE RECORD))
(RECORD (QUOTE EDGE))
(DEFLIST(QUOTE(
(GROUP (NIL))
))(QUOTE RECDEFAULT))
(DEFLIST(QUOTE(
(MARKERS (NIL))
))(QUOTE RECDEFAULT))
(DEFLIST(QUOTE(
(STRUCFORM FORM)
))(QUOTE !RECORD))
(!RECORD (QUOTE STRUCFORM))
(DEFLIST(QUOTE(
(ATTACHBIVALENTS NIL)
(ATTACHBIVS&LOOPS NIL)
(ATTACHFVS NIL)
(STRUCTURESWITHATOMS NIL)
))(QUOTE READVICE))
(READVISE ATTACHBIVALENTS ATTACHBIVS&LOOPS ATTACHFVS
STRUCTURESWITHATOMS)
STOP